home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 001 / tmodem23.arc / DIRECT.INC < prev    next >
Encoding:
Text File  |  1985-05-05  |  11.0 KB  |  341 lines
  1.  
  2.    type
  3.       Char80arr       = array [ 1..80 ] of Char;
  4.  
  5. (****************************************************************************)
  6. (*                         GET DEFAULT DRIVE LETTER                         *)
  7. (****************************************************************************)
  8.    function
  9.       default_drive : char;
  10.    var
  11.       regs          : registerset;
  12.    begin
  13.       regs.AX := $1900;
  14.       msdos( regs );
  15.       default_drive := chr(ord('A')+lo(regs.AX));
  16.    end;
  17.  
  18. (****************************************************************************)
  19. (*                          CHANGE DEFAULT DRIVE                            *)
  20. (****************************************************************************)
  21.    procedure
  22.       change_drive(dr : char);
  23.    var
  24.       regs            : registerset;
  25.    begin
  26.       regs.AX := $0E00;
  27.       regs.DX := ord(upcase(dr)) - ord('A');
  28.       msdos( regs );
  29.    end;
  30.  
  31. (****************************************************************************)
  32. (*                          DISK SPACE AVAILABLE                            *)
  33. (****************************************************************************)
  34.    function
  35.       diskspace(dr : char) : integer;
  36.    var
  37.       regs         : registerset;
  38.       r            : real;
  39.    begin
  40.       regs.AX := $3600;
  41.       regs.DX := 1 + ord(upcase(dr)) - ord('A');
  42.       msdos( regs );
  43.       r := ((regs.AX * regs.CX * 1.0) * regs.BX);
  44.       diskspace := round( r / 1024.0);
  45.    end;
  46.  
  47. (****************************************************************************)
  48. (*                           TIME SERVICE ROUTINES                          *)
  49. (****************************************************************************)
  50.    function
  51.       time       : string80;
  52.    var
  53.       reg        : registerset;
  54.       h,m,s,w    : string[10];
  55.       i          : integer;
  56.    begin
  57.       reg.AX := $2C00;
  58.       intr($21,reg);
  59.       str(hi(reg.CX):2,h);
  60.       str(lo(reg.CX):2,m);
  61.       str(hi(reg.DX):2,s);
  62.       w := h + ':' + m + ':' + s;
  63.       for i:=2 to 8 do if w[i]=' ' then w[i]:='0';
  64.       time:=w;
  65.    end;
  66.    function
  67.       delta_time(t1,t2 : string80) : string80;
  68.    var
  69.       h,m,s       : integer;
  70.       th,tm,ts,tw : string[10];
  71.    begin
  72.       h:=bval(copy(t2,1,3)) - bval(copy(t1,1,3));
  73.       m:=bval(copy(t2,4,3)) - bval(copy(t1,4,3));
  74.       s:=bval(copy(t2,7,3)) - bval(copy(t1,7,3));
  75.       if s<0 then begin
  76.          s:=s+60;
  77.          m:=m-1;
  78.       end;
  79.       if m<0 then begin
  80.          m:=m+60;
  81.          h:=h-1;
  82.       end;
  83.       if h<0 then h:=h+24;
  84.       str(h:2,th);
  85.       str(m:2,tm);
  86.       str(s:2,ts);
  87.       tw:=th+':'+tm+':'+ts;
  88.       for s:=2 to 8 do if tw[s]=' ' then tw[s]:='0';
  89.       delta_time := tw;
  90.    end;
  91.  
  92. (****************************************************************************)
  93. (*                     DISPLAY CURRENT DRIVE\DIRECTORY                      *)
  94. (****************************************************************************)
  95.    procedure
  96.       displ_curr_dr;
  97.    var
  98.       curdir       : string80;
  99.       dn           : integer;
  100.       ch           : char;
  101.    begin
  102.       ch:=default_drive;
  103.       dn:=ord(ch)-ord('A')+1;
  104.       getdir(dn,curdir);
  105.       writeln(' Current Drive\Directory: ',curdir);
  106.    end;
  107.  
  108. (****************************************************************************)
  109. (*                            FILE COPY ROUTINE                             *)
  110. (****************************************************************************)
  111.    procedure
  112.       copy_file;
  113.    type
  114.       buffer_pointer = ^buffer_type;
  115.       buffer_type    = array[ 1..128 ] of byte;
  116.    var
  117.       source, dest   : file;
  118.       sourcename     : string40;
  119.       destname       : string40;
  120.       recsread       : integer;
  121.       buff_pointer   : buffer_pointer;
  122.    begin
  123.       mkwin(10,3,71,11,'File Copy');
  124.       writeln;
  125.       displ_curr_dr;
  126.       writeln;
  127.       repeat
  128.          write(' Copy from: ');
  129.          readln(sourcename);
  130.          if length(sourcename)=0 then begin
  131.             rmwin;
  132.             exit;
  133.          end;
  134.          assign(source,sourcename);
  135.          {$I-}
  136.          reset(source);
  137.          {$I+}
  138.          ok := (ioresult=0);
  139.          if not ok then
  140.             writeln(' Cannot find file: ',sourcename);
  141.       until ok;
  142.       repeat
  143.          write(' Copy to  : ');
  144.          readln(destname);
  145.          if length(destname)=0 then begin
  146.             close( source );
  147.             rmwin;
  148.             exit;
  149.          end;
  150.          assign(dest,destname);
  151.          {$I-}
  152.          rewrite(dest);
  153.          {$I+}
  154.          ok := (ioresult=0);
  155.          if not ok then
  156.             writeln(' Cannot create file: ',destname);
  157.       until ok;
  158.       new( buff_pointer );
  159.       repeat
  160.          blockread(source,buff_pointer^,1,recsread);
  161.          blockwrite(dest,buff_pointer^,1);
  162.       until recsread=0;
  163.       close( dest );
  164.       close( source );
  165.       dispose( buff_pointer );
  166.       rmwin;
  167.    end;
  168.  
  169. (****************************************************************************)
  170. (*                          DISK DIRECTORY LISTER                           *)
  171. (****************************************************************************)
  172.    procedure
  173.       dir_list;
  174.  
  175.    {$I-}
  176.  
  177.    var
  178.       DTA          : array [ 1..43 ] of Byte;
  179.       DTAseg,
  180.       DTAofs,
  181.       SetDTAseg,
  182.       SetDTAofs,
  183.       Error,
  184.       I, J,
  185.       Option       : Integer;
  186.       Regs         : registerset;
  187.       Buffer,
  188.       NamR         : String80;
  189.       Mask         : Char80arr;
  190.       horz_tab     : byte;
  191.  
  192. (****************************************************************************)
  193. (*  SetDTA resets the current DTA to the new address specified in the       *)
  194. (*  parameters 'SEGMENT' and 'OFFSET'.                                      *)
  195. (****************************************************************************)
  196.       procedure
  197.          SetDTA( Segment, Offset : Integer; var Error : Integer );
  198.       begin
  199.          Regs.AX := $1A00;
  200.          Regs.DS := Segment;
  201.          Regs.DX := Offset;
  202.          MSDos( Regs );
  203.          Error := Regs.AX and $FF;
  204.       end;
  205.  
  206. (****************************************************************************)
  207. (*  GetCurrentDTA is used to get the current Disk Transfer Area ( DTA )     *)
  208. (*  address.  A function code of $2F is stored in the high Byte of the AX   *)
  209. (*  register and a call to the predefined procedure MSDos is made.  This    *)
  210. (*  can also be accomplished by using the "Intr" procedure with the same    *)
  211. (*  register record and a $21 specification for the interrupt.              *)
  212. (****************************************************************************)
  213.       procedure
  214.           GetCurrentDTA( var Segment, Offset : Integer;
  215.                          var Error : Integer );
  216.       begin
  217.          Regs.AX := $2F00;
  218.          MSDos( Regs );
  219.          Segment := Regs.ES;
  220.          Offset := Regs.BX;
  221.          Error := Regs.AX and $FF;
  222.       end;
  223.  
  224. (****************************************************************************)
  225. (*  GetFirst gets the first directory entry of a particular file Mask.  The *)
  226. (*  Mask is passed as a parameter 'Mask'.                                   *)
  227. (****************************************************************************)
  228.       procedure
  229.          GetFirst( Mask : Char80arr; var NamR : String80;
  230.                    Segment, Offset : Integer; Option : Integer;
  231.                    var Error : Integer );
  232.       var
  233.          I : Integer;
  234.       begin
  235.          Error := 0;
  236.          Regs.AX := $4E00;
  237.          Regs.DS := Seg( Mask );
  238.          Regs.DX := Ofs( Mask );
  239.          Regs.CX := Option;
  240.          MSDos( Regs );
  241.          Error := Regs.AX and $FF;
  242.          I := 1;
  243.          repeat
  244.             NamR[ I ] := Chr( mem[ Segment : Offset + 29 + I ] );
  245.             I := I + 1;
  246.          until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
  247.          NamR[ 0 ] := Chr( I - 1 );
  248.       end;
  249.  
  250. (****************************************************************************)
  251. (*  GetNextEntry uses the first bytes of the DTA for the file Mask, and     *)
  252. (*  returns the next file entry on disk corresponding to the file Mask.     *)
  253. (****************************************************************************)
  254.       procedure
  255.          GetNextEntry( var NamR : String80; Segment, Offset : Integer;
  256.                        Option : Integer; var Error : Integer );
  257.       var
  258.          I : Integer;
  259.       begin
  260.          Error := 0;
  261.          Regs.AX := $4F00;
  262.          Regs.CX := Option;
  263.          MSDos( Regs );
  264.          Error := Regs.AX and $FF;
  265.          I := 1;
  266.          repeat
  267.             NamR[ I ] := Chr( mem[ Segment : Offset + 29 + I ] );
  268.             I := I + 1;
  269.          until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
  270.          NamR[ 0 ] := Chr( I - 1 );
  271.       end;
  272.  
  273. (****************************************************************************)
  274. (*                        LIST DIRECTORY OF DISK                            *)
  275. (****************************************************************************)
  276.    begin
  277.       mkwin(1,1,80,24,'Disk Directory');
  278.       horz_tab := 4;
  279.       for I := 1 to 21 do DTA[ I ] := 0;
  280.       for I := 1 to 80 do begin
  281.          Mask[ I ] := Chr( 0 );
  282.          NamR[ I ] := Chr( 0 );
  283.       end;
  284.       NamR[ 0 ] := Chr( 0 );
  285.       GetCurrentDTA( DTAseg, DTAofs, Error );
  286.       if ( Error <> 0 ) then begin
  287.          WriteLn( 'Unable to get current DTA' );
  288.          WriteLn( 'Program aborting.' );
  289.          Halt;
  290.       end;
  291.       SetDTAseg := Seg( DTA );
  292.       SetDTAofs := Ofs( DTA );
  293.       SetDTA( SetDTAseg, SetDTAofs, Error );
  294.       if ( Error <> 0 ) then begin
  295.          WriteLn( 'Cannot reset DTA' );
  296.          WriteLn( 'Program aborting.' );
  297.          Halt;
  298.       end;
  299.       Error := 0;
  300.       Buffer[ 0 ] := Chr( 0 );
  301.       Option:=16;
  302.       displ_curr_dr;
  303.       Write('                Dir Mask: ' );
  304.       ReadLn( Buffer );
  305.       WriteLn;
  306.       if ( length( Buffer ) = 0 ) then
  307.          Buffer := '*.*';
  308.       for I := 1 to length( Buffer ) do
  309.          Mask[ I ] := Buffer[ I ];
  310.       GetFirst( Mask, NamR, SetDTAseg, SetDTAofs, Option, Error );
  311.       if ( Error = 0 ) then begin
  312.          gotoxy(horz_tab,wherey);
  313.          Write( NamR );
  314.          horz_tab := horz_tab + 15;
  315.       end
  316.       else
  317.          WriteLn( '   File ''', Buffer, ''' not found.' );
  318.       while ( Error = 0 ) do begin
  319.          GetNextEntry( NamR, SetDTAseg, SetDTAofs, Option, Error );
  320.          if ( Error = 0 ) then begin
  321.             gotoxy(horz_tab,wherey);
  322.             Write( NamR );
  323.             horz_tab := horz_tab + 15;
  324.             if horz_tab > 70 then begin
  325.                horz_tab := 4;
  326.                writeln;
  327.             end;
  328.          end;
  329.       end;
  330.       SetDTA( DTAseg, DTAofs, Error );
  331.       if horz_tab > 4 then
  332.          writeln;
  333.       writeln;
  334.       writeln('   Bytes Available: ',diskspace(default_drive),'k');
  335.       write('  ');
  336.       wait_for_key;
  337.       rmwin;
  338.    end;
  339.  
  340.    {$I+}
  341.